COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(cgol) $
C00044 00003	β
C00045 ENDMK
C⊗;
(cgol) $

%=====================CGOL SOURCE FILE=========================%

%  Read PRATT;CGOLMA > if you are wondering what this is.
   If you just want to use this file as a reference manual, the part you
   probably want is the table of CGOL operators headed "BASE COMPONENT" %

=(syntax?-needed := nil;
  sail := nil;
  let readtable=lispsyn; cgolchar(":");
  subst(";LOADING CGOL " cat
	(if status(feature, newio) then
		caddr(truename(infile)) else cadr status(#uread)),
	'msg',
	'if not status(feature,noldmsg) then new ?↑w; write 'msg'; newline')) $

temobarray := nil; normalobarray := obarray; % temporary %
ibase := base := 5+5;
if status(feature,complr) then ?*lexpr(union,intersect,setdiff,symdiff) $

%Pending a better way of coping with GC overflow: %
gc?-overflow := '\x;nil' $

%=================GOT - GENERALIZED OPERATOR TRANSLATOR===================%

declare(fixsw := t, ?*lexpr(#cat), ibase:=base:=5+5) $

special gotsyn, lispsyn, 	% GOT and LISP syntax tables %
	token,	% token currently pointed to by input pointer %
	stringnud, % null unless TOKEN is a string, when STRINGNUD is its nud %
	syntax?-needed,  % null when forms not to be eval'd by DEFFIX, DEFINE %
	oldread, oldprin1, oldtty, % used by CGOL and EXIT %
	teconame,   % name of user's teco, defaulted to T %
	drbp,       % declared in DEFFIX, used by RIGHT %
	fun,        % function name for use by RIGHTM in *FIX defs - ditto % 
	dentype, isfun,      % set by DEFFIX, used by IS  %
	silence,    % number defining "silence" when MOANing %
	defbp,      %default binding power for DEFINE%
	ivars, whenvar, result, body, % needed (blech) for "ITER" %
	obarray, temobarray, normalobarray,
	cgolfile, cgoltty, oldcgolfile, oldcgoltty,  % flags to say who is using CGOL %
	eofm ,	% end-of-file marker - test with EQ %
	nudl, ledl, lbpl,	% list of languages currently understood %
	cnud, cled, clbp $	% language currently being learned %

define "ADVANCE" ;	  % advances pointer %
	stringnud := nil; token := read(eofm);
	if token eq eofm then throw(token, eofm) else token  $

define "VERIFY"(den);  if den then (advance; den) $ % only advances if den ok %

define "NUDERR" ;  	% treats unknowns and functions as variables %
if getden lbpl
   and null getl(token, !'(subr fsubr lsubr expr fexpr lexpr macro
				*expr *fexpr *lexpr autoload))
 then (moan
 =(if sail then 'if token eq "?≠" then "?$" else token' else 'token')
 cat " MISSING PRECEDING EXPRESSION" level 2; err())
else let op = token, tp = tyipeek(); advance;
	["LAMBDA", nil,
		["QUOTE",
		  if getl(op, !'(subr fsubr lsubr expr fexpr lexpr macro
				  *expr *fexpr *lexpr autoload array))
		     and tp isin !'(9. 13. 32.)
		     and (stringnud
			  or getden nudl and token ne "("
			  or not getden lbpl)
		  then [op, parse("RBP" of op or 25)]
		  else op]]   $

define "LEDERR" ;	% treats unknown token as felonious %
    moan token cat " IS NOT AN OPERATOR WITH A LEFT ARGUMENT"  level 2; err() $

define "GETDEN" indl; indl and ((car indl) of token or getden cdr indl) $

define "NUD";   verify(stringnud or if token isnum then ["LAMBDA", nil, token]
					else getden nudl)
		or nuderr  $     % if no NUD, call user's error routine %

define "LED";	verify getden ledl or lederr $

define "PARSE" rbp;
iter for translation := funcall(nud) step funcall(led, translation)
     while rbp < (getden lbpl or 0)
     return translation $

define lexpr "CGOLREAD" (argno);
new;
let readtable = gotsyn, eofm = if zerop argno then eofm else arg 1;
	errset(while catch(advance, eofm) eq "?≠"
			or token eq eofm and zerop argno
		  do newline;
	       if token eq eofm then return arg 1;
	       if not ?↑q and #obarray = temobarray
			then obarray := normalobarray;
	       catch(return(parse -1 & =if sail then 'newline'), eofm);
	       moan "EOF ENCOUNTERED INSIDE CGOL-EXP - CGOLREAD" level 2);
	if ?↑q then exit;
	if token ne "?≠" then
	(new ?↑w; newline; iter for i := 1 step i+1 until tyipeek() isin !'(27 36 3 12)
do if i<40 then tyo tyi() else tyi()); err() $

define lexpr "LCREAD" (argno);
tyipeek();
if zerop argno then
(new x; while eofm eq x :=
		apply(if if ?↑q then cgolfile else cgoltty
		      then "CGOLREAD" else "READ",
		      [eofm])
	do newline;
	x)
else apply(if if ?↑q then cgolfile else cgoltty
	   then "CGOLREAD" else "READ",
	   arg[1 to argno]) $

"LBP" of "?≠" := -1 $

%-------CGOL ENTRY AND EXITS-------%

nilfix "CGOL" is "CGOL" $

define fexpr "CGOL"(a); % To read CGOL expressions %
    if null a then
	(let x = if ?↑Q then "CGOLFILE" else "CGOLTTY";
	let y = "OLD" cat x;
	set(y, (eval x) . eval y); set(x, t);
	#read := "LCREAD";
	if not ?↑q then
	   (oldprin1 := #prin1 . oldprin1;
	    oldtty := status(tty) . oldtty;
	    sstatus(tty, oct(232020202020), oct(232222200223));
	    "CGOL"))
    else if a = !'(nil) then cgolchar(":") $

define "EXIT";
let x = if ?↑Q then "CGOLFILE" else "CGOLTTY";
let y = "OLD" cat x;
if eval y then
(set(x, car eval y); set(y, cdr eval y);
if not ?↑Q then (#prin1 := car oldprin1; oldprin1 := cdr oldprin1;
		 sstatus(tty, caar oldtty, cadar oldtty);
		 oldtty := cdr oldtty; nil)) $

define "LISP";  % To enter LISP %
	#read := #prin1 := cgoltty := cgolfile :=
		oldcgoltty := oldcgolfile := oldprin1 := oldtty := nil;
	sstatus(tty, oct(232020202022), oct(232220200233));
	"LISP" $

define "CGOLCHAR" x;  apply("SSTATUS", ["MACRO", x, ''\; cgolread()'']) $
% (cgolchar ":") defines : as the cgol-invoking character macro %

prefix "EXPORT" 0  ['progn', ['quote', getvarlist],
	'normalobarray := obarray;
	 obarray := temobarray := ?*array(nil,'obarray')'] $
% EXPORT "encapsulates" any new symbols encountered while ?↑q remains true (cf.
CGOLREAD).  "Exported" symbols are not so encapsulated because they are
mentioned before OBARRAY is bound to the temporary obarray, which is discarded
as soon as either EXPORTALL is done or CGOLREAD is done from the TTY.  (This
will lose if the user enters and returns from break-level - suggestions for
fix?)  %

nilfix "EXPORTALL" 'obarray := normalobarray' $

nilfix "TECO" is "TECO"$
"AUTOLOAD" of "TECO" := !'(LISPT FASL DSK LIBLSP) $

define "TEC";  % To enter TECO; does UREAD;↑Q:=T on return %
valret(teconame cat "λ"); uread; ?↑Q := t $

define "SPEAK"(x);
nudl := x cat "NUD" . nudl;
ledl := x cat "LED" . ledl;
lbpl := x cat "LBP" . lbpl $

define "FORGET";
cdr nudl and (nudl := cdr nudl; ledl := cdr ledl; lbpl := cdr lbpl) $ 

define "RESETLANGUAGE";
nudl := !'(NUD); ledl := !'(LED); lbpl := !'(LBP);
cnud := "NUD"; cled := "LED"; clbp := "LBP" $

define "LEARN"(x); cnud := x cat "NUD"; cled := x cat "LED"; clbp := x cat "LBP" $

%===============BASE COMPONENT DEFINITIONAL FACILITY=====================%

nilfix	"RIGHT"		["PARSE",   drbp]  $  % to get a right hand argument %
nilfix	"RIGHTLIST"	["PARSELIST", drbp, '","']  $  % ditto, list of args %
nilfix	"RIGHTREP"	["PARSELIST", drbp, ["QUOTE", fun]] $

%------ *FIX OPERATORS -------%

define	"DEFFIX" (dentype, isfun, fun, dlbp, drbp);   % define *FIX fun %
let form := "DEFUN" .
	    [fun, dentype] .
	    (if dentype = cled then !'(left)) .
	    (advance; deprognify(parse 0));
if dlbp then form := ["PROGN", !''compile, form, ["DEFPROP", fun, dlbp, clbp]];
if syntax?-needed then eval form; form $

prefix	"NILFIX"   0	deffix(cnud, "ISN", token, nil,     nil    )  $
prefix	"PREFIX"   0	deffix(cnud, "ISP", token, nil,     advance)  $
prefix	"SUFFIX"   0	deffix(cled, "ISS", token, advance, nil    )  $
prefix	"INFIX"    0	deffix(cled, "ISI", token, advance, token  )  $
prefix	"INFIXR"   0	deffix(cled, "ISI", token, advance, token-1)  $
prefix	"INFIXD"   0	deffix(cled, "ISI", token, advance, advance)  $
prefix	"INFIXM"   0	deffix(cled, "ISM", token, advance, token  )  $

nilfix	"DELIM"	let form :=
		"PROGN" . for i in getvarlist collect ["DEFPROP", i, 0, clbp];
 		if syntax?-needed then eval form; form $

%------ "IS" OPERATOR ------%

prefix	"IS"	25	isfun .
			(if dentype = cled then !'(left)) @
			[right] @
			(if drbp then [drbp]) @
			if isfun = "ISM" then [["QUOTE", fun]]  $
% where "isfun" is one of: %

define	"ISN"(fcn);		[fcn]			$  % is nilfix %
define	"ISS"(left, fcn);	[fcn, left]		$  % is suffix %
define	"ISP"(fcn, rb);		[fcn, parse rb]		$  % is prefix %
define	"ISI"(left, fcn, rb);	[fcn, left, parse rb]	$  % is infix  %
define	"ISM"(left, fcn, rb, cont);  fcn . left . parselist(rb, cont) $ % is infixm %

%============AUXILIARY METALANGUAGE FUNCTIONS=========%

define	"CHECK"	del;
if token = del or not atom del and token isin del then advance
else moan "MISSING " cat del cat " INSERTED BEFORE " cat
     =if sail then 'if token eq "?≠" then "?$" else token' else 'token'
   level 0   $

define lexpr "CAT"(n);    % concatenates arguments  %
	implode append{explodec[arg[1 to n]]} $

define "PARSELIST"(rb, cont);
	parse rb . if token eq cont then (advance; parselist(rb, cont)) $

define	"GETVARLIST";     % for making up a list of variables - no parsing %
if token ne ";" or stringnud then (token & advance) .
		     if token = "," then (advance; getvarlist)$

define	"GETTOKENS";  % for reading a list of tokens, no commas (used in I/O) %
if not token isin !'(/) /] /' ≠ /;) then (token & advance) . gettokens $

define "DEPROGNIFY"(x); if not atom x and car x = "PROGN" then cdr x else [x] $

define "NOTIFY" x; x ne t and if not atom x and car x = "NOT" then cadr x else ["NOT", x] $

define "ORIFY" x; x and if not atom x and null cdr x then car x else "OR" . x $

define fexpr "LITERAL" (x); for i in x do set(i,i) $

define	"MOAN"	message "LEVEL" db , 2;
   if db > silence then 
      new ?↑w; 
      write message; if ?↑Q then princ "IN " cat fun $

%=========================EXTENSION FACILITY==============================%

% Allows user to define CGOL operators without reference to the target
language.  Closely resembles LISP's DEFUN (DEFPROP f l EXPR) facility %

prefix	"DEFINE"	0 
new fun, type, argts, code, instr, lb, rb, expr, form;
  expr := if token isin !'(expr fexpr lexpr macro) then (token & advance)
						   else "EXPR";
  if stringnud or tyipeek() = 40 %left-paren% then
			(argts := nil; type := cnud; code := ["LIST"];
		     instr := ["PROG2", nil, ["QUOTE", token]] )
  else (argts := [token];   advance;   type := cled;
	code := ["LIST", ["QUOTE",token]];   instr := ["PROG2", nil, 'left'] );
  fun := token; advance;
  if token = "(" and not stringnud 
  then (advance; argts := if token ne ")" then getvarlist;
	if expr = "LEXPR" then (argts := car argts; expr := "EXPR");
        check ")"; code := nil; instr := nil)
  else while not (token = ";" or token = ",") or stringnud do
           (while stringnud do
		(instr := instr @ [["CHECK", ["QUOTE", token]]];
	 	 form := ["DEFPROP", token, 0, clbp] . form;
	 	 advance);
            code := code @ [instr];
            if (token = ";" or token = ",") and not stringnud 
		then instr := nil
     		else (instr := ["PROG2", nil, ["PARSE", "#RBP"]];
	              argts := argts @ [token] ;  advance));
  lb := if type = cled then
	if token = "," then (advance; eval parse(1)) else defbp;
  rb := if token = "," then (advance; eval parse(1)) else lb or defbp;
  code := subst(rb, "#RBP", code @ if instr then [instr]);
  check ";" ;
  if code then (form := "PROGN" .
			!''compile .
			["DEFUN", [fun, type], (if type = cled then !'(left)), code] .
			(if lb then [["DEFPROP", fun, lb, clbp]]) @
 			nreverse form;
		if syntax?-needed then eval form);
  if token ne "?≠"
	then form :=  form @ ["DEFUN" . fun .
					(if expr ne 'expr' then [expr]) @
					[argts] @
					deprognify right];
  if code then form else car form $

defbp := 25 $

%=======================LEXICAL SYNTAX===================================%

%--------LEXICAL EXTENSION OPERATORS--------%

define "PUTTOK" a;
  new readtable, tok, synbits;
  setq(readtable, gotsyn);
  tok := explodec a;
   if length(tok) < 2 then return a;
   synbits := apply("STATUS", ["SYNTAX", car tok]);
   if synbits :A: oct(600040) = oct(600000) then
      (setsyntax(car tok, "MACRO", ["LAMBDA", nil,
	       ["READTOK",
		car tok,
		"TAILS" of car tok
		      := inserttok(cdr tok, "TAILS" of car tok)]]);
       setsyntax(car tok, oct(604500) :V: synbits, nil))
					% preserve old syntax %
   else (moan """" cat car tok cat
	   """ illegal first char of extended token" level 2;  err());
a $

define fexpr "DEFTOK"(a);  for tok in a do puttok tok $

nilfix	"NEWTOK"	let form := "DEFTOK" . getvarlist;
			if syntax?-needed then eval form; form $

define "INSERTTOK"(tok, toktable);
   if null(tok) then toktable
   else (new st;
         if st := assq(car tok, toktable)
            then (rplacd(st, inserttok(cdr tok, cdr st)); toktable)
            else (car tok . inserttok(cdr tok, nil)) . toktable) $

%-----LEXICAL SUPPORT ROUTINES-----%

define "+CGOL-""-READMACRO";	% reads string literals %
   new lc, ch;  ch := ascii(tyipeek());
   while not memq(ch, !'($ ≠)) do
      (readch();
       if ch eq """" then if tyipeek() = 34. then readch() else return nil
       else if ch eq "?" and tyipeek() isin !'(27. 36.) then ch := readch();
       lc := ch . lc ;  ch := ascii(tyipeek()));
   if not ch eq """" then moan "MISSING "" INSERTED BEFORE ?≠" level 0;
   lc := implode(nreverse(lc)) & stringnud := ["LAMBDA", nil, ["QUOTE", ["QUOTE", lc]]] $

define "+CGOL-%-READMACRO";	% reads comments %
   while tyi() ne 37 do nil; nil $

define "+CGOL-!-READMACRO";	% reads S-expression %
   (\readtable; read())(lispsyn) $

define "UPPER" x; if 96<x<123 then x-32 else x $

define fexpr "READTOK" (a);	% reads extended token %
   implode(car a . readtail(cadr(a))) $

define "READTAIL"(toktable);
   let x := ascii upper tyipeek();
   if assq(x, toktable) exists then (tyi(); x . readtail(cdr it)) $

%-----CGOL'S LEXICAL TABLE-----%

oct(			% all constants are octal %
let readtable = ?*array(nil, "READTABLE", t); setq(gotsyn, readtable);
for c in explodec("ε⊂∩∪#&'()*,/:;<=>@[\]↑`{|}}") do
   (sstatus{["MACRO", c, nil]};
    setsyntax(c, 600500, c));	% all non-alphanumerics are single char obj. %
setsyntax("?≠", 601540, nil);	% altmode is force-feed %
=if sail then 'setsyntax((ascii 175), 601540, nil)';	% altmode force-feed %
setsyntax("?$", 600540, "?≠");	% dollar maps to altmode %
setsyntax("←", 2, "-");	% ← maps to - %
setsyntax("+", 600510, nil);	% + is plus sign in numbers %
setsyntax("-", 600510, nil);	% - is minus sign in numbers %
setsyntax(".", 600700, nil);	% . is decimal point in numbers %
setsyntax("?", 402500, nil);	% ? is quote character in symbols %
setsyntax("""", "MACRO", "+CGOL-""-READMACRO");		% string %
setsyntax("%", "SPLICING", "+CGOL-%-READMACRO");	% comments %
setsyntax("!", "MACRO", "+CGOL-!-READMACRO");		% S-expression %
setsyntax(3, "SPLICING", '\;?↑q:=nil');	 % EOF %
sstatus(syntax, 15, 500500);	% cr acts like space %
ttyread := nil) $	% gobble only on forcefeed chars %

newtok ":=" $

base := ibase := 10. $

if not boundp("LISPSYN") then
    setq(lispsyn, readtable) $	% gets original LISP syntax %
"NUD" of "CGOLPRINT" := '\;  ["CGOLPRINT", parse 1]' $
"NUD" of "CGOLPRIN1" := '\; ["CGOLPRIN1", parse 1]' $
"AUTOLOAD" of "CGOLPRIN1" := "AUTOLOAD" of "CGOLPRINT" :=
	=if sail then '!'(CGPRIN FASL DSK(MAC LSP))'
		 else '!'(CGPRIN FASL DSK PRATT)' $

%===========================BASE COMPONENT===================================%


%------BRACKETING OPERATORS-------%
prefix	"("	0	right & check ")"    $
delim	")"	$
infixd	"("	30 0	left . if token ne ")" then rightlist & check ")"   $
delim	","	$
infixd	"{"	30 0	"APPLY" . ["FUNCTION", left] . rightlist & check "}" $
delim	"}" $
prefix	"["	0	if token ne "]" then
			 (let a = "LIST".rightlist;
			  if token = ")" then ["CIRC",a] else a)
			& check !'(] /)) $
define	"CIRC"(x); x & cdr last x := x$
delim	"]"	$
infixd	"["	30 0 
	if token = "{" then (advance;
			     sublis(['a'.left, 'b'.right],
				    'mapcar{function a . b}')&
			     check "}")
	else "MAPCAR" . ["FUNCTION", left] . rightlist
	& check "]" $
prefix	"OCT"	0	(\ibase; check "("; right)(8) & check ")" $

%---------LITERAL OPERATORS----------%
prefix	"'"	0	is "QUOTE" & check "'" $
delim	"'" $
prefix	"#"	25	token & advance   $  % removes significance of token %
prefix	"="	25	eval right  $  % for on the spot computation %
% Note that "string quotes", %%comment quotes%% and !(ONE S-EXPRESSION)
are character macros, defined above when the lexical syntax is set up.%
 
%--------DECLARATIVE OPERATORS---------%
prefix	"\"	0	"LAMBDA".(getvarlist & check ";"). deprognify(right)
			& if token = "\" then advance $
delim	"\"	$
prefix	"LET"	0
new vars, argts, packflag;
while token not isin !'(/; in) do
  (vars := vars @ getvarlist;
   check !'(be /:= =);
   argts := (if token = "{" then ["&UNP", advance;right & packflag:=t; check "}"]
	    else parse 1) . argts;
   if token = "," then advance);
advance;
if packflag then
  (argts := reverse for i in argts collect
	if car i = "&UNP" then cadr i else ['list', i];
   ["APPLY", ["FUNCTION", "LAMBDA".vars.deprognify right],
	     if length argts = 1 then car argts else "APPEND".argts])
else ("LAMBDA".vars.deprognify right) . nreverse argts  $

prefix	"PROG"	0	"PROG" . (getvarlist & check ";") . deprognify(right) $
prefix	"NEW"	0
	"PROG" .
	(getvarlist & check ";") . 
	let x = deprognify(right); let y = last x; car y := ["RETURN", car y]; x $
prefix	"SPECIAL" 1	["DECLARE", ("SPECIAL" . getvarlist)]   $
prefix	"LITERAL" 1	"LITERAL" . rightlist $

define fexpr "CGOLARRAY" (x);
if token = "(" then (advance; car x . (\y;["SUB1",y])[parselist(0, ",")] & check ")")
else if token = ":=" then (advance; ["FILLARRAY", car x, parse 1])
else car x $

prefix	"ARRAY"	0	if token isin !'(/( { [) then "ARRAY"
else let names = getvarlist;
let oldnuds = for name in names collect cnud of name;
for name in names do
cnud of name := ["LAMBDA", nil, ["CGOLARRAY", name]];
  if token = "(" then
  (advance; let dims = rightlist;
  check ")"; let type = if token isin !'(fixnum flonum nil t) then
  (token&advance) else t;
  let source = if token isin !'(/:= =) then (advance; parse 1);
  if token = ";" then
  (advance;
   ("LAMBDA" . names . (if source then for name in names collect
		["FILLARRAY", name, source])
			@ deprognify right) .
	for name in names collect "ARRAY" . nil . type . dims)
  else
  "PROG2" . nil . ["QUOTE", car names] .
    for name in names coalesce
	["DEFPROP", name, "NUD" of name, "NUD"] .
	["SETQ", name, "ARRAY" . nil . type . dims] .
	 if source then [["FILLARRAY", name, source]])
  else if token = ";" then (advance;right)
& for name in names, oldnud in oldnuds do
    if oldnud then cnud of name := oldnud
    else remprop(name,cnud) $

prefix	"DIM"	25	["CDR", ["ARRAYDIMS", right]] $

%--------CONTROL OPERATORS---------%
"RBP" of "EVAL" := 1 $
infixm	";"	1	is "PROGN" $
infixr	"&"	1	["PROG2", nil, left, right] $
prefix	"IF"	2	"COND" . (right . (check "THEN"; deprognify(right)))
			. (if token eq "ELSE" then
	(advance; let x=right; if car x = "COND" then cdr x else [t . deprognify(x)])) $
delim	"THEN"	$
delim	"ELSE"	$
"RBP" of "RETURN" := 1$
"RBP" of "GO" := 1$
prefix	"WHILE"	2	"DO" . nil . [NOTify(right)] . (check "DO"; deprognify(right)) $
prefix	"REPEAT" 2	["DO", nil, ["PROG2" .
				     deprognify(right) @
				     deprognify(check "UNTIL";right)]] $
delim	"DO"  $

prefix	"FOR"	1 
new pars, argts, inon, fcn, body;
pars:= [token]; inon := advance; advance;
fcn := assoc(inon, !'((in (do mapc) (collect mapcar) (coalesce mapcan))
 		      (on (do map) (collect maplist) (coalesce mapcon))));
if fcn then fcn := cdr fcn 
  else (moan inon cat " FOUND WHERE IN OR ON EXPECTED" level 2; err());
argts := [right];
while token eq "," do
   (pars := advance . pars; advance; check inon; argts := right . argts);
fcn := assoc(token, fcn); if fcn then fcn := cadr fcn
      else (moan token cat " FOUND WHERE DO, COLLECT OR COALESCE EXPECTED"
	  level 2; err());
advance; argts := nreverse argts; pars := nreverse pars; body := right;
if fcn = "MAPC" and and{(\x;car x = "TO")[argts]}
	then "DO" .
	     (for p in pars, a in argts collect
 	       [p, cadr a, if cadddr a = 1 then ["ADD1", p]
					   else ["PLUS", p, cadddr a]]) .
	     [ORify((\p,a; ["GREATERP", p, caddr a])[pars,argts])] .
	     deprognify(body)
else fcn . ["FUNCTION", if cdr body = pars and atom car body then car body
			else ["LAMBDA", pars, body]] . argts $

delim "IN"; delim "ON"; delim "COLLECT"; delim "COALESCE" $

prefix "ITER" 2 
	new ivars, whenvar, result, body;
	while assoc(token, !'(
(for:	 ivars := (token .
		   if advance = ":=" then (advance; right exists) .
		   if token = "STEP" then
			 [if advance = "DITTO" then (advance; it) else right])
	    . ivars$)
(when:	 whenvar := right$)
(until:	 whenvar := right$)
(while:	 whenvar := ["NOT", right]$)
(return: result  := right$)
(do:	 body    := right$)))
	      exists do (advance; eval cadr it);
	if not( ivars or whenvar or result or body) then body := right;
        ["DO", nreverse ivars, [whenvar, result]] @
           if not atom body and car body eq "PROGN"
              then cdr body else ncons body  $

delim "FOR", "WHEN", "UNTIL", "WHILE", "STEP", "RETURN"$
infix "TO" 18 "TO" . left . right . [if token = "BY" then (advance;right) else 1] $
delim "BY" $

define	"TO"(aa, b, c);
if aa>b then nil
else new x; x := [aa] & while b>=aa:=aa+c do x := cdr(cdr x := [aa]) $

infixd	"LOTSOF" 19 1	["DO", '?*i', left, '?*i-1', '?*i<=0', right] $

%------STORAGE OPERATORS-------%
infixd	":="	25 1	if left isatom then is "SETQ"
			else if car left eq "GET" then
				["PUTPROP",cadr(left),right,caddr(left)]
			else if "STOREFORM" of car left exists then
				(\x;sublis(["LEFT".cadr left, "RIGHT".right], x))(it)
			else is "STORE" $ %prop%

'storeform' of 'car'   := 'rplaca(left,#right)';
'storeform' of 'cdr'   := 'rplacd(left,#right)';
'storeform' of 'arg'   := 'setarg(left,#right)';
'storeform' of 'plist' := 'setplist(left,#right)';
'storeform' of 'status' := 'sstatus(left,#right)' $

for i in !'(toplevel breaklevel who2 who3 ttyscan ttyread ttyint gctime) do
	"NUD" of i := subst(i, "I", !'(lambda () '(status i))) $

infixr	"OF"	26	["GET", right, left]  $
infixr	"OFQ"	26	["GET", right, ["QUOTE", left]]  $

%-----LOGICAL OPERATORS-------%
"RBP" of "NOT" := 9 $
infix	"NOT"	10	["NOT", funcall(led, left)] $
infixm	"AND"	8	is "AND" $
infixm	"OR"	7	is "OR" $

%-----RELATIONAL OPERATORS-----%
newtok "=#"; newtok "=?$"; newtok "<#"; newtok ">#";
newtok "<?$"; newtok ">?$"; newtok "<="; newtok ">=" $
infix	"="	10	is "EQUAL" $
infix	"NE"	10	["NOT", is "EQUAL"] $
infix	"EQ"	10	is "EQ" $
infixm	"<"	10	is "LESSP" $
infixm	">"	10	is "GREATERP" $
infix	"=#"	10	is "=" $
infix	"=?$"	10	is "=" $  % for those who care %
infix	"<#"	10	is "<" $
infix	">#"	10	is ">" $
infix	"<?$"	10	is "<" $  %  "    "    "   "   %
infix	">?$"	10	is ">" $  %  "    "    "   "   %
infix	"<="	10	["NOT", is "GREATERP"] $
infix	">="	10	["NOT", is "LESSP"] $
infix	"|"	10	["ZEROP", ["REMAINDER", right, left]] $
infix	"ISIN"	10	is "MEMBER"  $
suffix	"ISATOM" 10	is "ATOM"   $  %  atom x  also works %
suffix	"ISNUM"	10	is "NUMBERP"   $ % numberp x also works %
suffix	"EXISTS" 10	errset(eval !'(special it), nil); ["SETQ", "IT", left] $
"RBP" of "NULL" := 10 $

%--------LIST OPERATORS--------%
infixr	"."	15	is "CONS" $
infixm	"@"	15	is "APPEND" $

%--------SET OPERATORS---------%
prefix	"{"	0	"GATHER" . if token ne "}" then rightlist & check "}" $
infixm	"∪"	16	is "UNION" $
infixm	"∩"	16	is "INTERSECT" $
prefix	"}"	16	is "SETDIFF" $
infixm	"}"	16	is "SETDIFF" $
infixm	"ε"	10	is "ELEMENTP" $
infixm	"⊂"	10	is "SUBSETP" $
for s in
!'(GATHER UNION INTERSECT SETDIFF ELEMENTS ELEMENTP SUBSETP SYMDIFF CLEARSETS)
do 'autoload' of s := !'(SETS FASL DSK LIBLSP)$
%Do sailint(nil) to inhibit tty interrupts for sail union, intersect, elementp%
define sailint(x); for i in !'(6 22 23) do sstatus(#ttyint, i, x) $

%--------STRING OPERATORS-----%
infixm	"↑"	18	is "CAT" $
infixm	"CAT"	18	is "CAT" $

%-----ARITHMETIC OPERATORS-----%
prefix	"|"	19	is "ABS"  & check "|"   $

prefix	"+"	20	if token isin !'(/( { [) then "PLUS" else right $
infixm	"+"	20	is "PLUS" $
infixm	"-"	20	is "DIFFERENCE" $
prefix	"-"	20	is "MINUS" $
nilfix	"*"		if token isin !'(/( [ {) then "TIMES" else "*" $
infixm	"*"	21	is "TIMES" $
infixm	"/"	21	["QUOTIENT", left, ["FLOAT", right]] $
newtok	"/:"	$
infixm	"/:"	21	is "QUOTIENT" $
infix	"REM"	21	is "REMAINDER" $
declare(fixsw := nil)$
define a "MOD" b, 21; let x := a rem b;
	    if minusp a ne minusp b and not zerop x then x+b else x $
declare(fixsw := t)$

newtok	"**" $
infixr	"**"	22	is "EXPT" $

%-----FIXNUM OPERATORS--------%
newtok "+#"; newtok "-#"; newtok "*#"; newtok "/#"; newtok "\\" $
infixm	"+#"	20	is "+" $
infixm	"-#"	20	is "-" $
infixm	"*#"	21	is "*" $
infixm	"/#"	21	is "/" $
infix	"\\"	19	is "\\" $

%-----FLONUM OPERATORS---------%
newtok "+?$"; newtok "-?$"; newtok "*?$"; newtok "/?$" $
infixm	"+?$"	20	is "+?$" $
infixm	"-?$"	20	is "-?$" $
infixm	"*?$"	21	is "*?$" $
infixm	"/?$"	21	is "/?$" $

%-----BIT-VECTOR OPERATORS-----%
newtok ":N:"; newtok ":A:"; newtok ":V:"; newtok ":X:"; newtok ":↑:" $
prefix	":N:"	21	["BOOLE", 12, 0, right] $
infixm	":A:"	21	"BOOLE" . 1 . left . rightrep $
infixm	":V:"	20	"BOOLE" . 7 . left . rightrep $
infixm	":X:"	20	"BOOLE" . 6 . left . rightrep $
infix	":↑:"	22	is "LSH" $

%-----I/O OPERATORS-----%
"RBP" of "PRINT" := 2 $
"RBP" of "PRINC" := 2 $
"RBP" of "PRIN1" := 2 $
prefix	"WRITE"	2	
   subst("LIST".rightlist,'x','newline;for i in x do princ i;princ " "')$
nilfix	"NEWLINE"	is "TERPRI"  $
nilfix	"UREAD"		"UREAD" . gettokens $
nilfix	"UWRITE"	"UWRITE" . gettokens $
nilfix	"UFILE"		"UFILE" . gettokens $
nilfix	"LOAD"		"FASLOAD" . gettokens $

%==================INITIALIZATION================%

oldprin1 := nil; oldtty := status(tty); teconame := syntax?-needed := t;
#read := "LCREAD"; cgolfile := cgoltty := oldcgolfile := oldcgoltty := nil;
stopwatch:=0; silence := -1; defbp := 25; eofm := [nil] ;
nudl := !'(nud); ledl := !'(led); lbpl := !'(lbp);
cnud := "NUD"; cled := "LED"; clbp := "LBP";
"*LEXPR" of "CAT" := t; fun := "TOP-LEVEL"; ?*nopoint t;
sstatus(featur, #cgol)  $



=exit $

β